home *** CD-ROM | disk | FTP | other *** search
/ Programming Sound Cards / Programming Sound Cards.iso / sound_56 / plays3m.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-01-01  |  15.2 KB  |  445 lines
  1. {$M 16000,0,2000}
  2. program example_for_s3mplay;
  3.  
  4. uses emstool,S3MPlay,crt,blaster,dos;
  5.  
  6. const stereo_calc=true;
  7.       _16bit_calc=false;
  8.       switch:array[false..true] of string[3] = ('off','on ');
  9.  
  10. var samplerate:word;
  11.     Stereo:Boolean;
  12.     _16bit:Boolean;
  13.     _LQ:boolean;
  14.     ST3order:Boolean;
  15.     help:boolean;
  16.     volume:byte;
  17.     how2input:byte; { 1-autodetect,2-read blaster enviroment,3-input by hand }
  18.     disply_c:boolean;
  19.     screen_no:byte;  { current info on screen }
  20.     startchn:byte;
  21.  
  22. {$L DOSPROC.OBJ}
  23. function getfreesize:word; external;
  24.  
  25. function tohexs(w:word):string;
  26. const s:string='0123456789ABCDEF';
  27.   begin
  28.     tohexs:=s[(w shr 12)+1] + s[((w shr 8) and $0f)+1] + s[(w and $00ff) shr 4+1] + s[(w and $000f)+1];
  29.   end;
  30.  
  31. procedure display_errormsg(err:integer);
  32.   begin
  33.     { I know case is stupid - like my code allways is :) }
  34.     case err of
  35.        0: write(' Hmm no error what''s wrong ? ');
  36.       -1: begin
  37.           if load_error=-1 then write(' Not enough memory for this module. ') else
  38.           if player_error=-1 then write(' Not enough memory for internal buffers. ');
  39.           write('PROGRAMMERS INFO: Try to lower PascalHeap or DMAbuffer. ');
  40.           end;
  41.       -2: write(' Wrong file format. Not a S3M ? ');
  42.       -3: write(' File corrupt. ');
  43.       -4: write(' File does not exist. ');
  44.       -7: write(' Need a 386 or higher. ');
  45.       -8: write(' No sounddevice set. (wrong code - shame on you programmer) ');
  46.       -11: write(' Loading stoped by user <- only for betatest ! ');
  47.     else write(' Somethings going wrong, but I dounno about that errorcode: ',err,'  ');
  48.     end;
  49.     writeln('PROGRAM HALTED.'#7);
  50.     halt;
  51.   end;
  52.  
  53. var filename:string;
  54.     c:char;
  55.     savchn:array[0..15] of byte;
  56.  
  57. procedure save_chntyps;
  58. var i:byte;
  59.   begin
  60.     for i:=0 to 15 do savchn[i]:=channel[i].channeltyp;
  61.   end;
  62.  
  63. procedure revers(n:byte);
  64.   begin
  65.     if channel[n].channeltyp=0 then channel[n].channeltyp:=savchn[n]
  66.     else channel[n].channeltyp:=0
  67.   end;
  68.  
  69. procedure hide_cursor; assembler;
  70.  asm
  71.    mov  ah,01
  72.    mov  cx,32*256+32
  73.    int  10h
  74.  end;
  75.  
  76. procedure view_cursor; assembler;
  77.  asm
  78.    mov  ah,01
  79.    mov  cx,15*256+16
  80.    int  10h
  81.  end;
  82.  
  83. var oldexit:pointer;
  84.  
  85. procedure local_exit; far;
  86.   begin
  87.     exitproc:=oldexit;
  88.   end;
  89.  
  90. function nextord(nr:byte):byte;
  91.   begin
  92.     patterndelay:=0;Ploop_on:=false;Ploop_no:=0;Ploop_to:=0;
  93.     inc(nr);
  94.     while (nr<=lastorder) and (order[nr]>=254) do inc(nr);
  95.     if nr>lastorder then
  96.       if loopS3M then
  97.         begin
  98.           nr:=0;
  99.           while (nr<=lastorder) and (order[nr]>=254) do inc(nr);
  100.           if nr>lastorder then EndofSong:=true; { stupid order ! (no real entry) }
  101.         end
  102.       else begin nr:=0;EndofSong:=true end;
  103.     nextord:=nr;
  104.   end;
  105.  
  106. procedure disable_all;
  107. var i:byte;
  108.   begin
  109.     for i:=0 to usedchannels-1 do
  110.       channel[i].enabled:=false;    { <- use this if you jump to previous order ... }
  111.   end;
  112.  
  113. function prevorder(nr:byte):byte;
  114.   begin
  115.     if nr=0 then begin prevorder:=nr;exit end;
  116.     dec(nr);
  117.     while (nr>0) and (order[nr]>=254) do dec(nr);
  118.     if order[nr]>=254 then { to far - search next playable }
  119.       begin
  120.         while (nr<=lastorder) and (order[nr]>=254) do inc(nr);
  121.         if nr>lastorder then EndofSong:=true; { stupid order ! (no real entry) }
  122.       end;
  123.     prevorder:=nr;
  124.   end;
  125.  
  126. function upstr(s:string):string;
  127. var i:byte;
  128.   begin
  129.     for i:=1 to length(s) do s[i]:=upcase(s[i]);
  130.     upstr:=s;
  131.   end;
  132.  
  133. procedure check_para(p:string);
  134. var t:string;
  135.     b:byte;
  136.     w:word;
  137.     i:integer;
  138.   begin
  139.     if (p[1]<>'-') and (p[1]<>'/') then
  140.       begin
  141.         filename:=p;
  142.         exit;
  143.       end;
  144.     if upcase(p[2])='V' then { Volume }
  145.       begin
  146.         t:=copy(p,3,length(p)-2);
  147.         val(t,b,i);
  148.         if i=0 then volume:=b;
  149.       end;
  150.     if upcase(p[2])='S' then { Samplerate }
  151.       begin
  152.         t:=copy(p,3,length(p)-2);
  153.         val(t,w,i);
  154.         if i=0 then
  155.           begin
  156.             if w<100 then w:=w*1000;
  157.             SampleRate:=w;
  158.           end;
  159.       end;
  160.     if (upcase(p[2])='H') or (p[2]='?') then { help } help:=true;
  161.     if upcase(p[2])='M' then { Mono - because default is stereo } stereo:=false;
  162.     if p[2]='8' then { 8bit - default is 16bit } _16bit:=false;
  163.     if upcase(p[2])='C' then { display SB config } disply_c:=true;
  164.     if upcase(p[2])='R' then { show rastertime } rastertime:=true;
  165.     if upcase(p[2])='O' then { use ST3 order } ST3order:=true;
  166.     if upstr(copy(p,2,5))='NOEMS' then { don't use EMS } useEMS:=false;
  167.     if upstr(copy(p,2,3))='ENV' then { read Blaster enviroment } how2input:=2;
  168.     if upstr(copy(p,2,3))='CFG' then { input SB config by hand } how2input:=3;
  169.     if upstr(copy(p,2,2))='LQ' then { mix in low quality mode } _LQ:=true;
  170.     {$IFDEF BETATEST}
  171.     if upcase(p[2])='B' then
  172.       begin
  173.         t:=copy(p,3,length(p));
  174.         val(t,b,i);
  175.         if i=0 then startorder:=b;
  176.       end;
  177.     if upcase(p[2])='F' then { set frame rate }
  178.       begin
  179.         t:=copy(p,3,length(p)-2);
  180.         val(t,b,i);
  181.         if i=0 then FPS:=b;
  182.       end;
  183.     {$ENDIF}
  184.   end;
  185.  
  186. procedure display_keys;
  187.   begin
  188.     writeln(' Keys while playing : '#13#10);
  189.     writeln(' <P> ... Pause (only on SB16)');
  190.     writeln(' <L> ... enable/disable loopflag');
  191.     writeln(' <D> ... doshelling :)');
  192.     writeln(' <Alt> <1>..<''>,<Q>..<R> - Switch On/Off channel 1..16 ');
  193.     writeln(' <+> ... Jump to next pattern');
  194.     writeln(' <-> ... Jump to previous pattern');
  195.     writeln(' <ESC> ... Stop playing');
  196.     writeln(' <F1> ... help screen');
  197.     writeln(' <F2> ... Display channel infos');
  198.     writeln(' <F3> ... Display current pattern');
  199.     writeln(' <F4> ... Display instrument infos');
  200.     writeln(' <F5> ... Display sample memory positions');
  201.   end;
  202.  
  203. procedure display_help;
  204.   begin
  205.     writeln(' Usage :');
  206.     writeln('  PLAYS3M <options> <S3M Filename> '#13#10);
  207.     writeln('    ■ Order does not matter');
  208.     writeln('    ■ if no extension then ''.S3M'' is added');
  209.     writeln('    ■ Options:  (use prefixes ''/'' or ''-'' to mark it as option)');
  210.     writeln('         /Vxxx    ... set master volume 0..255 ');
  211.     writeln('                      (default=0 - use master volume is specified in S3M)');
  212.     writeln('         /Sxxxxx  ... set samplerate ''4000...45454'' or ''4..46''(*1000)');
  213.     writeln('                      (higher SampleRate -> better quality !)');
  214.     writeln('         /H or /? ... Show this screen ');
  215.     writeln('                      (funny eh - yo you get it easier with no parameter)');
  216.     writeln('         /M       ... use mono mixing');
  217.     writeln('                      (default is stereo if it''s possible on your SB)');
  218.     writeln('         /8       ... use 8bit mixing');
  219.     writeln('                      (default is 16bit if it''s possible on your SB)');
  220.     writeln('         /C       ... display configuration after detecting');
  221.     writeln('                      (default is display not)');
  222.     writeln('         /ENV     ... use informations of blaster envirment');
  223.     writeln('         /CFG     ... input SB config by hand');
  224.     writeln('                      (default is SB hardware autodetect)');
  225.     write(' a key for next page ...');
  226.     readkey;
  227.     write(#13);clreol;
  228.     writeln('         /O       ... handle order like ST3 does');
  229.     writeln('                      (default is my own way - play ALL patterns are defined');
  230.     writeln('                      in Order)');
  231.     writeln('         /R       ... display raster time');
  232.     writeln('         /NOEMS   ... don''t use EMS for playing (player won''t use any EMS ');
  233.     writeln('                      after this) - if there''s no free EMS, player''ll set');
  234.     writeln('                      also <don''t use EMS>');
  235.  
  236.     writeln('         /LQ      ... use low quality mode');
  237.     {$IFDEF BETATEST}
  238.     writeln(' for debugging: ');
  239.     writeln('         /Bxx     ... start at order xx (default is 0)');
  240.     writeln('         /Fxx     ... set Frames Per Second (default is 70Hz)');
  241.     {$ENDIF}
  242.     if not help then writeln('Gimme a filename :)');
  243.     halt(1);
  244.   end;
  245.  
  246. procedure display_playercfg;
  247.   begin
  248.     writelnSBconfig;
  249.   end;
  250.  
  251. procedure display_helpscreen;
  252.   begin
  253.     textcolor(white);textbackground(blue);
  254.     window(1,8,80,25);clrscr;
  255.     writeln;
  256.     display_keys;
  257.     window(1,1,80,25);
  258.   end;
  259.  
  260. function getfreeEMS:longint;
  261. var Regs : Registers;
  262. begin
  263.   getfreeEMS:=0;
  264.   if not EMSinstalled then exit;
  265.   Regs.ah := $42;                { Fkt.no.: get number of free pages }
  266.   Intr($67, Regs);
  267.   if (Regs.ah <>0 ) then exit    { something was not right ... :( }
  268.   else getfreeEMS := Regs.bx;
  269. end;
  270.  
  271. procedure mainscreen;
  272. CONST SW_order:array[false..true] of string = ('Extended Order','Normal Order');
  273.       SW_stereo:array[false..true] of string = ('Mono','Stereo');
  274.       SW_qual:array[false..true] of string = ('Hiquality','Lowquality');
  275.       sw_res:array[false..true] of string = ('8bit','16bit');
  276.   begin
  277.     textbackground(blue);window(1,1,80,25);clrscr;
  278.     gotoxy(1,7);textbackground(yellow);clreol;writeln('Channel  Stereo ELC Inst Note  Period  Step  Vol Effect');
  279.     textbackground(white);textcolor(black);
  280.     gotoxy(1,1);clreol;write('Order:   (  ) Row:    Tick:                  that is Pattern:    ');
  281.     textbackground(green);textcolor(black);gotoxy(1,6);clreol;write(' Title: ',songname);
  282.     gotoxy(50,6);write('EMS usage: ',switch[useEMS],' Loop S3M : ');
  283.     textbackground(blue);textcolor(lightgray);
  284.     gotoxy(1,3);write(' Samplerate: ',getSamplerate:5,'  ',sw_stereo[stereo],', ',sw_res[_16bit],
  285.     ', ',sw_order[ST3order],', ',sw_qual[LQmode]);
  286.     gotoxy(1,4);write(' Free DOS memory : ',longint(16)*getfreesize:6,' bytes  Free EMS memory : ',getfreeEMS*16:5,' KB');
  287.     gotoxy(1,5);write(' Used EMS Memory : ',(getusedEMSsmp+getusedEMSpat):5,' KB  <F1> - Help screen',
  288.                       '':13,'Playerversion: ',version:3:2);
  289.   end;
  290.  
  291. procedure refr_mainscr;
  292.   begin
  293.     textbackground(white);textcolor(black);
  294.     gotoxy(8,1);write(curOrder:2);
  295.     gotoxy(11,1);write(lastorder:2);
  296.     gotoxy(20,1);write(curline:2);
  297.     gotoxy(29,1);write(curtick:2);
  298.     gotoxy(63,1);write(curpattern:2,' (',tohexs(pattern[curpattern]),')');
  299.     textbackground(green);textcolor(black);
  300.     gotoxy(76,6);write(switch[loopS3M]);
  301.     gotoxy(1,2);
  302.     textbackground(magenta);textcolor(yellow);
  303.     write(' Speed: ',getspeed:3,' '#179' Tempo: ',gettempo:3,' '#179' GVol: ',
  304.           gvolume:2,' '#179' MVol: ',get_mvolume:3,' '#179' Pdelay: ',get_delay:2,' '#179' Ploop: ');
  305.     if Ploop_on then write(Ploop_to,'(',PLoop_no,')') else write(Ploop_to);
  306.     clreol;
  307.   end;
  308.  
  309. {$I REFRESH.INC}  { refresh the different screens }
  310. {$I PREPARE.INC}  { prepare the different screens }
  311.  
  312. var i:byte;
  313.  
  314. begin
  315.   { setup defaults: }
  316.   Samplerate:=45454;
  317.   Stereo:=stereo_calc;
  318.   _16bit:=_16bit_calc;
  319.   _LQ:=false;
  320.   help:=false;
  321.   volume:=0; { use volume given in S3M ... }
  322.   how2input:=1; { autodetect SB }
  323.   disply_c:=false;
  324.   filename:='';
  325.   ST3order:=false;
  326.   {$IFDEF BETATEST}
  327.   startorder:=0;
  328.   {$ENDIF}
  329.   { end of default ... }
  330.   textbackground(black);textcolor(lightgray);
  331.   oldexit:=exitproc;
  332.   exitproc:=@local_exit;
  333.   for i:=1 to paramcount do
  334.     check_para(paramstr(i));
  335.   clrscr;
  336.   writeln(' S3M-PLAYER for SoundBlasters written by Cyder of Green Apple (Andre'' Baresel) ');
  337.   writeln(' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~');
  338.   writeln(' Version : ',version:3:2);
  339.   if (filename='') then display_help;
  340.   writeln;
  341.   {$IFDEF BETATEST}
  342.   writeln(' Free memory before loading : ',longint(16)*getfreesize);
  343.   writeln(' Free EMS memory before loading :',getfreeEMS*16,' KB');
  344.   {$ENDIF}
  345.   if not load_S3M(filename) then display_errormsg(load_error);
  346.   {$IFDEF BETATEST}
  347.   writeln(' Free memory after loading : ',longint(16)*getfreesize);
  348.   writeln(' Free EMS after loading : ',getfreeEMS*16,' KB');
  349.   {$ENDIF}
  350.   writeln(' ''',songname,''' loaded ... (was saved with ST',savedunder:4:2,')');
  351.   if not Init_S3Mplayer then display_errormsg(player_error);
  352.   {$IFDEF BETATEST} writeln(' player init done ... ');
  353.   display_keys;
  354.   write(#13#10' press a key to continue...');readkey;clrscr;gotoxy(1,19);{$ENDIF}
  355.   if not init_device(how2input) then begin writeln(' SoundBlaster not found sorry ... ');halt end;
  356.   {$IFDEF BETATEST} writeln(' init device (SB) done ... '); {$ENDIF}
  357.   if disply_c then
  358.     begin
  359.       display_playercfg;
  360.       write(#13#10' press a key to continue...');readkey;clrscr;gotoxy(1,19);
  361.     end;
  362.   { And here we go :) }
  363.   if volume>0 then set_mastervolume(volume);
  364.   setsamplerate(samplerate,stereo);
  365.   set_ST3order(ST3order);
  366.   save_chntyps;
  367.   loopS3M:=true;
  368.   screen_no:=1;startchn:=1;
  369.   if not startplaying(stereo,_16bit,_LQ) then display_errormsg(player_error);
  370.   mainscreen;
  371.   hide_cursor;
  372.   repeat
  373.     c:=#0;
  374.     refr_mainscr;
  375.     refresh_scr;
  376.     if keypressed then c:=readkey;
  377.     {if c<>#0 then write(ord(c));}
  378.     if (c>='x') and (c<=chr(ord('x')+16)) then begin revers(ord(c)-ord('x'));c:=#0 end;
  379.     if (ord(c)>=16) and (ord(c)<=19) then begin revers(ord(c)-4);c:=#0 end;
  380.     if (c>=#59) { F1 } and (c<=#63) { F5 } then
  381.       begin
  382.         screen_no:=ord(c)-59;
  383.         prepare_scr;c:=#0;
  384.       end;
  385.     if (upcase(c)='P') then
  386.       begin
  387.         pause_play;
  388.         readkey;
  389.         continue_play;
  390.         c:=#0;
  391.       end;
  392.     if (c='+') then
  393.         begin
  394.           curorder:=nextord(curorder);
  395.           lastrow:=0;curline:=0;curtick:=1;curpattern:=order[curorder];c:=#0
  396.         end;
  397.     if (c='-') then
  398.         begin
  399.           curorder:=prevorder(curorder);
  400.           patterndelay:=0;Ploop_on:=false;Ploop_no:=0;Ploop_to:=0;
  401.           disable_all;
  402.           lastrow:=0;curline:=0;curtick:=1;curpattern:=order[curorder];c:=#0
  403.         end;
  404.     if upcase(c)='L' then loopS3M:=not loopS3M;
  405.     if upcase(c)='D' then
  406.       begin
  407.         asm
  408.           mov ax,3
  409.           int 10h    { clear screen }
  410.         end;
  411.         writeln(' Return to player with ''EXIT'' ... ');
  412.         swapvectors;
  413.         exec(getenv('COMSPEC'),'');
  414.         swapvectors;
  415.         c:=#0;
  416.         asm
  417.           mov ax,3
  418.           int 10h
  419.         end;
  420.         hide_cursor;
  421.         if doserror<>0 then
  422.           begin
  423.             while keypressed do readkey;
  424.             writeln(' Doserror ',doserror);
  425.             writeln(' Hmm somethings going wrong with running a copy of COMMAND.COM ...');
  426.             writeln(' press any key to continue ... ');
  427.             readkey;
  428.           end;
  429.         mainscreen;
  430.       end;
  431.     if (c=#77) and (startchn<usedchannels) then begin inc(startchn);if screen_no=2 then prepare_scr; end;
  432.     if (c=#75) and (startchn>1) then begin dec(startchn);if screen_no=2 then prepare_scr; end;
  433.   until toslow or (c=#27) or (EndOfSong);
  434.   if toslow then writeln(' Sorry your PC is to slow ... ');
  435.   view_cursor;
  436.   stop_play;
  437.   done_module;
  438.   done_S3Mplayer;
  439.   gotoxy(1,8);
  440.   textcolor(white);textbackground(blue);
  441.   {$IFDEF BETATEST}
  442.   writeln(' Memory after all : ',longint(16)*getfreesize);clreol;
  443.   writeln(' EMS after all : ',getfreeEMS*16,' KB');clreol;
  444.   {$ENDIF}
  445. end.